; File:  HANOI.LSP  (c) 	    03/06/91		Soft Warehouse, Inc.


;		* * *	The Tower of Hanoi Puzzle   * * *

(SETQ *INIT-WINDOW* "Hanoi")
(SETQ *WINDOW-TYPES* (SORT (ADJOIN "Hanoi" *WINDOW-TYPES*) 'STRING<))
(SETQ DRIVER 'WINDOWS)

(DEFUN "Hanoi" (COMMAND
    *USE-COLOR* *RINGS* *SOUND-EFFECTS* *HIGH-SPEED* *INITIAL-POSITION*
    *STEP-MODE*
    *DELAY-TIME* *BLOCK-CHAR* )
  (SETQ *DELAY-TIME* 100)
  (SETQ *BLOCK-CHAR* (PROGN
	  ((EQ (CSMEMORY 855) 2) (ASCII 219))	    ;IBM PC?
	  ((<= 9 (CSMEMORY 855) 10) (ASCII 135))    ;NEC PC-9801 or Fujitsu
	  'X))
  ((EQ COMMAND 'CREATE-WINDOW)
    (LIST "Hanoi" T (MAX-RINGS) T NIL NIL NIL) )
  (SETQ *RINGS* (MIN *RINGS* (MAX-RINGS)))
  ((EQ COMMAND 'CLOSE-WINDOW))
  (UNWIND-PROTECT
    (PROGN
      ((EQ COMMAND 'UPDATE-WINDOW)
	(SETQ *INITIAL-POSITION*)
	(HANOI-DISPLAY) )
      (HANOI-STATUS)
      (LOOP
	(HANOI-DISPLAY)
	(EXECUTE-OPTION 'COMMAND *HANOI-OPTIONS*) ) )
    (UPDATE-STATE '(*USE-COLOR* *RINGS* *SOUND-EFFECTS*
		*HIGH-SPEED* *INITIAL-POSITION* *STEP-MODE*)) ) )

(SETQ *HANOI-OPTIONS* '(
	("Color" . HANOI-COLOR)
	("Go" . HANOI-RUN)
	("Options" . (
		("Color" . (
			("Menu" . SET-MENU-COLOR)
			("Work" . SET-WORK-COLOR) ))
		("Display" . SET-DISPLAY)
		("Execute" . GO-DOS) ))
	("Pace" . HANOI-SPEED)
	("Quit" . QUIT-PROGRAM)
	("Rings" . HANOI-RINGS)
	("Sound" . HANOI-SOUND)
	("Window" . CHANGE-WINDOW) ))

(DEFUN HANOI-COLOR ()
  (RPLACA (CAR HANOI-COLOR) (IF *USE-COLOR* "Yes" "No"))
  ((MODE-QUERY HANOI-COLOR)
    (SETQ *USE-COLOR* (EQ (CAAR HANOI-COLOR) "Yes")
	  *INITIAL-POSITION*)
    T) )

(SETQ HANOI-COLOR '(("Yes" "Use colors" "Rings" ("Yes" "No")) ))

(DEFUN HANOI-RINGS (
    RINGS)
  (RPLACA (CAR HANOI-RINGS) *RINGS*)
  (LOOP
    ((NOT (MODE-QUERY HANOI-RINGS)) NIL)
    (SETQ RINGS (PARSE-INTEGER-CAR (CAR HANOI-RINGS)))
    ((AND RINGS (<= 1 RINGS (MAX-RINGS)))
      (SETQ *RINGS* RINGS
	    *INITIAL-POSITION*)
      T )
    (ERROR-BEEP) ) )

(SETQ HANOI-RINGS '(("" "Enter number of rings to use" "Rings" 3) ))

(DEFUN MAX-RINGS ()
  (MIN (TRUNCATE (SUB1 (TRUNCATE (WINDOW-COLS) 2)) 3)
       (- (WINDOW-ROWS) 3)) )

(DEFUN HANOI-SPEED ()
  (RPLACA (CAR HANOI-SPEED)
	  (IF *HIGH-SPEED* "Fast" (IF *STEP-MODE* "Step" "Normal")))
  ((MODE-QUERY HANOI-SPEED)
    (SETQ *HIGH-SPEED* (EQ (CAAR HANOI-SPEED) "Fast")
	  *STEP-MODE* (EQ (CAAR HANOI-SPEED) "Step"))
    NIL ) )

(SETQ HANOI-SPEED '(
	("Normal" "Select program speed" "Mode" ("Fast" "Normal" "Step")) ))

(DEFUN HANOI-SOUND ()
  (RPLACA (CAR HANOI-SOUND) (IF *SOUND-EFFECTS* "Yes" "No"))
  ((MODE-QUERY HANOI-SOUND)
    (SETQ *SOUND-EFFECTS* (EQ (CAAR HANOI-SOUND) "Yes"))
    NIL ) )

(SETQ HANOI-SOUND '(("Yes" "Use sound effects" "Effects" ("Yes" "No")) ))

(DEFUN HANOI-RUN (
    PEG1-RINGS PEG2-RINGS PEG3-RINGS PEG1-COLUMN PEG2-COLUMN PEG3-COLUMN
    SOURCE-RINGS )
  ((< (WINDOW-ROWS) 4) NIL)
  (HANOI-DISPLAY)
  (SHOW-PROMPT "Press any key to abort")
  (CURRENT-WINDOW)
  (IF (<= 9 (CSMEMORY 855) 10)			;If NEC PC-9801 or Fujitsu,
      (MAPC 'WRITE-BYTE '(13 27 41 51)) )	;select graphics mode
  (CATCH 'QUIT-RUNNING (MOVE-RINGS *RINGS* 'PEG1 'PEG2 'PEG3))
  (IF (<= 9 (CSMEMORY 855) 10)			;If NEC PC-9801 or Fujitsu,
      (MAPC 'WRITE-BYTE '(13 27 41 48)) )	;select kanji mode
  (CURSOR-LINES NIL)
  (SETQ *INITIAL-POSITION*)
  NIL )

(DEFUN MOVE-RINGS (RINGS SOURCE-PEG TARGET-PEG SPARE-PEG)
  ((ZEROP RINGS))
  (MOVE-RINGS (SUB1 RINGS) SOURCE-PEG SPARE-PEG TARGET-PEG)
  (SETQ SOURCE-RINGS (GET SOURCE-PEG 'RINGS))
  (PUT TARGET-PEG 'RINGS (CONS (CAR SOURCE-RINGS) (GET TARGET-PEG 'RINGS)))
  (PUT SOURCE-PEG 'RINGS (CDR SOURCE-RINGS))
  (SET-CURSOR (- (WINDOW-ROWS) (LENGTH SOURCE-RINGS))
	      (- (GET SOURCE-PEG 'COLUMN) (CAAR SOURCE-RINGS)))
  (SET-RING-COLOR 7)
  (SPACES (CAAR SOURCE-RINGS))
  (PRINC *BLOCK-CHAR*)
  (SPACES (CAAR SOURCE-RINGS))
  (SET-RING-COLOR (CAAR SOURCE-RINGS))
  ( ((IDENTITY *HIGH-SPEED*))
    (PRINT-RING (CAAR SOURCE-RINGS) (CDAR SOURCE-RINGS)
		SOURCE-PEG *DELAY-TIME*)
    (IF (OR (EQ SOURCE-PEG 'PEG2) (EQ TARGET-PEG 'PEG2)) NIL
	(PRINT-RING (CAAR SOURCE-RINGS) (CDAR SOURCE-RINGS)
		'PEG2 *DELAY-TIME*) )
    (PRINT-RING (CAAR SOURCE-RINGS) (CDAR SOURCE-RINGS)
		TARGET-PEG *DELAY-TIME*) )
  (SET-CURSOR (- (WINDOW-ROWS) (LENGTH (GET TARGET-PEG 'RINGS)))
	      (- (GET TARGET-PEG 'COLUMN) (CAAR SOURCE-RINGS)))
  (PRINC (CDAR SOURCE-RINGS))
  (IF *HIGH-SPEED* NIL (TONE NIL *DELAY-TIME*))
; (IF (> *DELAY-TIME* 10) (DECQ *DELAY-TIME*))	    ;Accelerator
  ( ((NOT *STEP-MODE*))
    ((EQ (CONTINUE-PROMPT) 27)
      (THROW 'QUIT-RUNNING) )
    (SHOW-PROMPT "Press any key to abort")
    (CURRENT-WINDOW) )
  ( ((LISTEN T)
      (CLEAR-INPUT T)
      ((PROMPT-YN "Quit running puzzle")
	(THROW 'QUIT-RUNNING) )
      (SHOW-PROMPT "Press any key to abort")
      (CURRENT-WINDOW) ) )
  (MOVE-RINGS (SUB1 RINGS) SPARE-PEG TARGET-PEG SOURCE-PEG) )

(DEFUN PRINT-RING (RING-SIZE RING-STRING PEG TIME)
  ((SET-CURSOR (- (WINDOW-ROWS) *RINGS* 3) (- (GET PEG 'COLUMN) RING-SIZE))
    (WRITE-STRING RING-STRING)
    (SET-CURSOR (- (WINDOW-ROWS) *RINGS* 3) (- (GET PEG 'COLUMN) RING-SIZE))
    (TONE (IF *SOUND-EFFECTS* (CDR (ASSOC (CAAR SOURCE-RINGS) *NOTES*))) TIME)
    (SPACES (ADD1 (* 2 RING-SIZE))) )
  (TONE (IF *SOUND-EFFECTS* (CDR (ASSOC (CAAR SOURCE-RINGS) *NOTES*))) TIME) )

(SETQ *NOTES* '((1 . 523) (2 . 494) (3 . 440) (4 . 392) (5 . 349) (6 . 330)
	(7 . 294) (8 . 262) (9 . 247) (10 . 220) (11 . 196) (12 . 175)
	(13 . 165) (14 . 147) (15 . 131)))

(DEFUN HANOI-STATUS ()
  (CLEAR-STATUS "Hanoi")
  (WRITE-STRING "The Tower Of Hanoi Puzzle") )

(DEFUN HANOI-DISPLAY (
    RINGS ROW LST)
  (PUT 'PEG2 'COLUMN (TRUNCATE (WINDOW-COLS) 2))
  (PUT 'PEG1 'COLUMN (- (GET 'PEG2 'COLUMN) *RINGS* *RINGS* 1))
  (PUT 'PEG3 'COLUMN (+ (GET 'PEG2 'COLUMN) *RINGS* *RINGS* 1))
  (SETQ RINGS *RINGS*)
  (LOOP
    ((ZEROP RINGS))
    (PUSH (CONS RINGS (PACK (MAKE-LIST (ADD1 (* 2 RINGS)) *BLOCK-CHAR*))) LST)
    (DECQ RINGS) )
  (PUT 'PEG1 'RINGS LST)
  (PUT 'PEG2 'RINGS NIL)
  (PUT 'PEG3 'RINGS NIL)
  ((IDENTITY *INITIAL-POSITION*))
  (CURRENT-WINDOW T)
  (CURSOR-OFF)
  (IF (<= 9 (CSMEMORY 855) 10)			;If NEC PC-9801 or Fujitsu,
      (MAPC 'WRITE-BYTE '(13 27 41 51)) )	;select graphics mode
  (PRINT-PEG *RINGS* (WINDOW-ROWS) (GET 'PEG1 'COLUMN))
  (PRINT-PEG *RINGS* (WINDOW-ROWS) (GET 'PEG2 'COLUMN))
  (PRINT-PEG *RINGS* (WINDOW-ROWS) (GET 'PEG3 'COLUMN))
  (SETQ RINGS *RINGS*
	ROW (WINDOW-ROWS)
	LST (REVERSE (GET 'PEG1 'RINGS)))
  (LOOP
    ((ZEROP RINGS))
    (SET-CURSOR (DECQ ROW) (- (GET 'PEG1 'COLUMN) RINGS))
    (SET-RING-COLOR RINGS)
    (PRINC (CDR (POP LST)))
    (DECQ RINGS) )
  (IF (<= 9 (CSMEMORY 855) 10)			;If NEC PC-9801 of Fujitsu,
      (MAPC 'WRITE-BYTE '(13 27 41 48)) )	;select kanji mode
  (SETQ *INITIAL-POSITION* T) )

(DEFUN PRINT-PEG (RINGS ROW COLUMN)
  (SET-RING-COLOR 7)
  (LOOP
    (SET-CURSOR (DECQ ROW) COLUMN)
    (PRINC *BLOCK-CHAR*)
    ((ZEROP RINGS))
    (DECQ RINGS) ) )

(DEFUN SET-RING-COLOR (RING)
  ((NOT *USE-COLOR*))
  ((EQ (VIDEO-MODE) 7)
    ((ODDP RING)
      (FOREGROUND-COLOR 7) )
    (FOREGROUND-COLOR 15) )
  ((EQ (VIDEO-MODE) 15)
    ((ODDP RING)
      (FOREGROUND-COLOR 3) )
    (FOREGROUND-COLOR 15) )
  (FOREGROUND-COLOR (IF (EQ RING (BACKGROUND-COLOR)) 0 RING)) )


(OR (GETD 'WINDOWS T)
    (LOAD "WINDOWS.LSP")
    (SOME '(LAMBDA (FILE)
	     (SETQ FILE (NREVERSE (UNPACK FILE)))
	     (LOAD (PACK (NREVERSE (OR (MEMBER '\\ FILE) (MEMBER ': FILE))
				   (LIST "WINDOWS.LSP")))) )
	  (INPUT-FILES) )
    (TERPRI NIL T)
    (WRITE-LINE "Cannot find WINDOWS.LSP" T) )

(FRESH-LINE)
(PROGN (WRITE-LINE "Press the ESC key to start the Tower of Hanoi Puzzle.") NIL)
